;;;; checker-game.lisp

(in-package #:gamao-impl)

#|

We attempt at a level of generality covering both backgammon and narde, so the
generic functions LEGAL-PMOVE-P and PLAY-PMOVE do dispatch on playing rules.

A full move consists of partial moves.

There are two levels of legality of a partial move.

Level 1: playability as determined by the checker position. A partial move can
be *played* if the player has checkers on the starting position, if the target
is open, etc.  However, not every move that can be played is a part of a full
move.

Level 2: legality as determined by the global checker position as well as dice.
This corresponds to the rule that a player must play the greatest possible
number of pips.

The generic functions legal-pmove-p and play-pmove are applicable on both
levels and in general it's supposed that the latter can be safely called if the
former returns true.  The function classify-checker-position can be used to
wrap a given checker position into an instance of rich-checker-position, so
that legal-pmove-p for the latter take into account that as many pips as
possible must be played.

In the case of backgammon, the checker-position class can be wrapped by
rich-checker-position.  In the case of narde, a wrapper aware of the number of
checkers taken from the head must be applied first.

Admittedly, the following explanation is fairly obscure and may be skipped.

The class rich-checker-position wraps any checker position turning it into a
dice- and player-aware position.  Specifically, suppose that R is a set of
rules and P is a class of positions such that the generic functions

    legal-pmove-p position player start pips rules
    play-pmove position player start pips rules
    checker-position-won-by-p position player rules

have method specialized on position of class P and rules of class R.  A rich
position over p is an instance of rich-checker-position such that
(checker-position rp) is p.  If rp is a rich position over p, then rp also
encapsulates information about the current player and playable dice;
(legal-pmove-p rp player start pips rules) returns true if so does
(legal-pmove-p p player start pips rules) and, moreover, if pips is a playable
die and all playable dice can be played in subsequent partial moves.

Let P be a class of positions as above and rules be an instance of a subclass
of play-max-rule-mixin; then

    classify-checker-position p player pips1 pips2 rules

returns the rich position over p corresponding to the maximum number of
playable pips.
|#

(defgeneric legal-pmove-p (position player start pips rules))
(defgeneric play-pmove (position player start pips rules))
(defgeneric checker-position-won-by-p (position player rules))

;;; RICH-CHECKER-POSITION

#|
Given a checker position, a player, and dice, we perform a global analysis of
the position in order to understand what pips must constitute the full move.
This information is captured by the class of the analysed position.
|#

(defgeneric checker-position (position))
(defgeneric rcp-player (position))
(defgeneric rcp-pips (position n))
(defgeneric rcp-dice-count (position))
(defgeneric remaining-die (position die))
(defgeneric admissible-die-p (position die))
(defgeneric classify-checker-position (checker-position player pips1 pips2 rules))

(defclass rich-checker-position ()
  ((player :reader rcp-player :initarg :player)
   (checker-position :reader checker-position :initarg :checker-position)))

(defmethod rcp-pips ((position rich-checker-position) n)
  nil)

(defclass checker-position-different-dice (rich-checker-position)
  ((pips1 :initarg :pips1)
   (pips2 :initarg :pips2)))

(defmethod rcp-pips ((position checker-position-different-dice) (n (eql 0)))
  (slot-value position 'pips1))

(defmethod rcp-pips ((position checker-position-different-dice) (n (eql 1)))
  (slot-value position 'pips2))

(defmethod rcp-dice-count ((position checker-position-different-dice))
  2)

(defmethod admissible-die-p ((position checker-position-different-dice) die)
  (or (= die (rcp-pips position 0))
      (= die (rcp-pips position 1))))

(defmethod remaining-die ((position checker-position-different-dice) die)
  (let ((die1 (rcp-pips position 0))
        (die2 (rcp-pips position 1)))
    (if (= die die1)
        die2
        die1)))

(defclass checker-position-identical-dice (rich-checker-position)
  ((pips :initarg :pips)
   (dice-count :initarg :dice-count)))

(defmethod rcp-pips ((position checker-position-identical-dice) n)
  (slot-value position 'pips))

(defmethod rcp-dice-count ((position checker-position-identical-dice))
  (slot-value position 'dice-count))

(defmethod remaining-die ((position checker-position-identical-dice) die)
  die)

(defclass checker-position-no-dice (rich-checker-position)
  ())

(defmethod admissible-die-p ((position checker-position-identical-dice) die)
  (= die (rcp-pips position 0)))

(defmethod rcp-dice-count ((position checker-position-no-dice))
  0)

(defmethod admissible-die-p ((position checker-position-no-dice) die)
  nil)

;;; play-pmove is primarily delegated to the wrapped checker position, but
;;; after that the information about playable dice must be updated.

(defmethod play-pmove ((position rich-checker-position) player start pips rules)
  (make-instance 'rich-checker-position
                 :player player
                 :checker-position (play-pmove (checker-position position) player start pips rules)))

(defmethod play-pmove ((position checker-position-different-dice) player start pips rules)
  (change-class (call-next-method)
                'checker-position-identical-dice
                :pips (remaining-die position pips)
                :dice-count 1))

(defmethod play-pmove ((position checker-position-identical-dice) player start pips rules)
  (let ((remaining-die-count (1- (rcp-dice-count position))))
    (if (zerop remaining-die-count)
        (change-class (call-next-method)
                      'checker-position-no-dice)
        (change-class (call-next-method)
                      'checker-position-identical-dice
                       :pips pips
                       :dice-count remaining-die-count))))

(defmethod legal-pmove-p ((position rich-checker-position) player start pips rules)
  (if (not (eq (rcp-player position) player))
      (values nil 'opponents-turn)
      (let ((checker-position (checker-position position)))
        (if (not (admissible-die-p position pips))
            (values nil 'inadmissible-pips)
            (multiple-value-bind (valid-checker-move? reason) (legal-pmove-p checker-position player start pips rules)
              (if (not valid-checker-move?)
                  (values nil reason)
                  (let ((next-position (play-pmove checker-position player start pips rules)))
                    (if (checker-position-won-by-p next-position player rules)
                        (values t nil)
                        (let ((remaining-die (remaining-die position pips))
                              (remaining-die-count (1- (rcp-dice-count position))))
                          (if (can-play-identical-dice-p next-position player remaining-die remaining-die-count rules)
                              (values t nil)
                              (values nil 'cannot-play-rest-moves)))))))))))

;;; PLAY-MAX-RULE-MIXIN

(defclass play-max-rule-mixin ()
  ())

(defmacro do-starts ((location player &optional (start :bar) result-form) &body body)
  "Iterate through location IDs that can be used as starts of partial moves, starting from START and moving towards PLAYER's home board."
  (let ((start-v (gensym "START-"))
        (player-v (gensym "PLAYER-"))
        (rel-location-v (gensym "REL-LOCATION-")))
    `(let ((,start-v ,start)
           (,player-v ,player))
       (check-type ,start-v (or (eql :bar) (integer 1 24)))
       (check-type ,player-v (member :black :white))
       (let ((,rel-location-v (if (or (eq ,start-v :bar)
                                      (eq ,player-v :black))
                                  ,start-v
                                  (- 25 ,start-v)))
             (,location :bar))
         (loop
           (setf ,location (if (or (eq ,rel-location-v :bar)
                                   (eq ,player-v :black))
                               ,rel-location-v
                               (- 25 ,rel-location-v)))
           ,@body
           (setf ,rel-location-v (if (eq ,rel-location-v :bar)
                                     24
                                     (1- ,rel-location-v)))
           (when (zerop ,rel-location-v)
             (return ,result-form)))))))

(defun max-depth-identical-dice (checker-position player pips depth-limit playing-rules &optional (start-from :bar))
  (if (zerop depth-limit)
      0
      (let ((max-possible-depth 0))
        (do-starts (start player start-from)
          (when (legal-pmove-p checker-position player start pips playing-rules)
            (let* ((next-position (play-pmove checker-position player start pips playing-rules))
                   (possible-depth (1+ (max-depth-identical-dice next-position player pips (1- depth-limit) playing-rules start))))
              (setf max-possible-depth (max possible-depth max-possible-depth))
              (when (= max-possible-depth depth-limit)
                (return)))))
        max-possible-depth)))

(defun max-depth-different-dice (checker-position player pips1 pips2 rules)
  (let ((max-depth 0))
    (do-starts (start player)
      (when (legal-pmove-p checker-position player start pips1 rules)
        (let ((next-position (play-pmove checker-position player start pips1 rules)))
          (setf max-depth (1+ (max-depth-identical-dice next-position player pips2 1 rules)))
          (when (= max-depth 2)
            (return)))))
    max-depth))

(defun can-play-identical-dice-p (checker-position player pips count rules)
  (= (max-depth-identical-dice checker-position player pips count rules) count))

(defun classify-position-different-dice (checker-position player pips1 pips2 rules)
  (let ((max-pips (max pips1 pips2))
        (min-pips (min pips1 pips2)))
    (let ((depth-from-greatest (max-depth-different-dice checker-position player max-pips min-pips rules)))
      (if (= depth-from-greatest 2)
          (values 'can-play-both nil)
          (let ((depth-from-least (max-depth-different-dice checker-position player min-pips max-pips rules)))
            (cond ((= depth-from-least 2) (values 'can-play-both nil))
                  ((= depth-from-greatest 1) (values 'can-play-one max-pips))
                  ((= depth-from-least 1) (values 'can-play-one min-pips))
                  (t (values 'can-play-none nil))))))))

(defun classify-position-identical-dice (checker-position player pips playing-rules)
  (max-depth-identical-dice checker-position player pips 4 playing-rules))

(defmethod classify-checker-position (checker-position player pips1 pips2 (rules play-max-rule-mixin))
  (let ((rich-position (make-instance 'rich-checker-position :player player :checker-position checker-position)))
    (if (= pips1 pips2)
        (let ((depth (classify-position-identical-dice checker-position player pips1 rules)))
          (if (plusp depth)
              (change-class rich-position 'checker-position-identical-dice :pips pips1 :dice-count depth)
              (change-class rich-position 'checker-position-no-dice)))
        (multiple-value-bind (kind datum) (classify-position-different-dice checker-position player pips1 pips2 rules)
          (ecase kind
            (can-play-both (change-class rich-position 'checker-position-different-dice :pips1 pips1 :pips2 pips2))
            (can-play-one (change-class rich-position 'checker-position-identical-dice :pips datum :dice-count 1))
            (can-play-none (change-class rich-position 'checker-position-no-dice)))))))

;;; BACKGAMMON RULES

(defclass backgammon-pmove-rules ()
  ())

(defmacro backgammon-pmove-rule (&key has-checkers-on-start? start-is-bar? finish-is-off? opponent-owns-finish? has-checkers-on-bar? all-at-home? is-short-move? start-is-farthest?)
  `(cond ((not ,has-checkers-on-start?) (values nil 'no-checkers-on-start))
         ((and ,has-checkers-on-bar? (not ,start-is-bar?)) (values nil 'hit-checkers-must-be-entered-first))
         (t (if ,finish-is-off?
                (cond ((not ,all-at-home?) (values nil 'not-all-checkers-at-home))
                      ((and ,is-short-move? (not ,start-is-farthest?) (values nil 'inadmissible-pips)))
                      (t (values t nil)))
                (if ,opponent-owns-finish?
                    (values nil 'finish-is-not-open)
                    (values t nil))))))

(defun checker-pmove-destination (player from pips)
  (check-type player (member :black :white))
  (check-type from (or (integer 1 24) (eql :bar)))
  (check-type pips (integer 1 6))
  (let* ((relative-start (cond ((eq from :bar) 25)
                               ((eq player :black) from)
                               ((eq player :white) (- 25 from))
                               (t (error "This should not happen."))))
         (relative-finish* (- relative-start pips)))
    (multiple-value-bind (relative-finish short-move?) (cond ((plusp relative-finish*) (values relative-finish* nil))
                                                             ((zerop relative-finish*) (values :off nil))
                                                             (t (values :off t)))
      (let ((absolute-finish (cond ((eq relative-finish :off) :off)
                                   ((eq player :black) relative-finish)
                                   (t (- 25 relative-finish)))))
        (values absolute-finish short-move?)))))

(defun opponent (player)
  (check-type player (member :black :white))
  (if (eq player :black)
      :white
      :black))

(defun players-point (point player)
  (if (or (eq player :black)
          (member point '(:off :bar)))
      point
      (- 25 point)))

(defconstant +checker-count+ 15)

(defun checkers-beyond-home-point (checker-position player point)
  "First value: is POINT a home point for PLAYER?
   Second value: POINT is a home point for PLAYER and PLAYER has not checkers beyond POINT."
  (if (eq point :bar)
      (values nil nil)
      (let ((ppoint (players-point point player)))
        (if (> ppoint 5)
            (values nil nil)
            (let ((checkers-not-beyond-point-or-off (checker-position-checkers-at checker-position :off player)))
              (do-starts (p player ppoint)
                (incf checkers-not-beyond-point-or-off
                      (checker-position-checkers-at checker-position p player)))
              (if (= checkers-not-beyond-point-or-off +checker-count+)
                  (values t t)
                  (values t nil)))))))

(defmethod legal-pmove-p ((checker-position checker-position) player from pips (rules backgammon-pmove-rules))
  (multiple-value-bind (to is-short-move) (checker-pmove-destination player from pips)
    (multiple-value-bind (all-at-home no-beyond-start) (checkers-beyond-home-point checker-position player from)
      (backgammon-pmove-rule :has-checkers-on-start? (plusp (checker-position-checkers-at checker-position from player))
                             :start-is-bar? (eq from :bar)
                             :finish-is-off? (eq to :off)
                             :opponent-owns-finish? (and (not (eq to :off))
                                                         (>= (checker-position-checkers-at checker-position to (opponent player)) 2))
                             :has-checkers-on-bar? (plusp (checker-position-checkers-at checker-position :bar player))
                             :all-at-home? all-at-home
                             :is-short-move? is-short-move
                             :start-is-farthest? no-beyond-start))))

(defmethod play-pmove ((checker-position checker-position) player from pips (rules backgammon-pmove-rules))
  (let* ((opponent (opponent player))
         (to (checker-pmove-destination player from pips))
         (hit-checkers (if (eq to :off)
                           0
                           (checker-position-checkers-at checker-position to opponent))))
    (let ((maybe-move-hit-on-bar (if (= hit-checkers 1)
                                     (checker-position-move-checker checker-position opponent to :bar)
                                     checker-position)))
      (checker-position-move-checker maybe-move-hit-on-bar player from to))))

(defmethod checker-position-won-by-p (checker-position player (rules backgammon-pmove-rules))
  (= (checker-position-checkers-at checker-position :off player) +checker-count+))


(defclass backgammon-checker-play-rules (play-max-rule-mixin backgammon-pmove-rules)
  ())

(defparameter *initial-backgammon-arrangement* '((24 2)
                                                 (13 5)
                                                 (8 3)
                                                 (6 5)))

(defun make-initial-backgammon-position ()
  (loop with checker-position = (make-checker-position)
        for (point checkers) in *initial-backgammon-arrangement*
        do (loop for player in '(:black :white)
                 do (setf checker-position (update-checker-position checker-position
                                                                    (players-point point player)
                                                                    player
                                                                    checkers)))
        finally (return checker-position)))
